VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ImageTGA"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'====================================================================================
'ImageTGA - Load a 32-Bit TGA image and store in memory as a DIB Section
'====================================================================================
'This class also supports basic animation by defining how many frames to divide the
'image file into (i.e. each frame side by side in the image)
Option Explicit

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function AlphaBlending Lib "msimg32.dll" Alias "AlphaBlend" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal BF As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Const BI_RGB = 0&         'Use RGB (or RGBA) colours
Private Const DIB_RGB_COLORS = 0  'Use a colour look up table (256 colours)

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 255) As RGBQUAD
End Type

'TGA Definition ---------------------------------------------------------------------
Private Type TGAHeader
    IDLength As Byte
    ColorMapType As Byte
    ImageType As Byte
    CMapStart As Integer
    CMapLength As Integer
    CMapDepth As Byte
    XOffset As Integer
    YOffset As Integer
    Width As Integer
    Height As Integer
    PixelDepth As Byte
    ImageDescriptor As Byte
End Type

'Class variables --------------------------------------------------------------------
Private MyDIB As Long
Private MyBMPOld As Long
Private MyhDC As Long
Private MyPointer As Long
Private MyBitmapInfo As BITMAPINFO  'The image structure

Private MyFrameCount As Long  'The number of frames, if the image is animated
Private MyFrameWidth As Long   'Width of one frame based on frame count
Public CurrentFrame As Long   'Current frame of the animation

'GET FrameCount: Return the number of frames (if animated), otherwise 0
'====================================================================================
Public Property Get FrameCount() As Long: FrameCount = MyFrameCount: End Property

'LET FrameCount: Set the number of frames of animation in the image
'====================================================================================
Public Property Let FrameCount(ByVal Value As Long)
    MyFrameCount = Value
    MyFrameWidth = (Me.Width \ MyFrameCount)
End Property

'GET BytesPerScanLine: The width of the image in bytes
'====================================================================================
Private Property Get BytesPerScanLine() As Long
    'Scans must align on dword boundaries:
    BytesPerScanLine = (MyBitmapInfo.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property

'GET Width: Return the width of the whole image
'====================================================================================
Public Property Get Width() As Long: Width = MyFrameWidth: End Property

'GET Height: Return the height of the image
'====================================================================================
Public Property Get Height() As Long
    Height = MyBitmapInfo.bmiHeader.biHeight
End Property

'GET hDC: Get the device context handle (for using API functions on the image)
'====================================================================================
Public Property Get hDC() As Long: hDC = MyhDC: End Property

'====================================================================================
'Animate: If the image has frames, move to the next and loop appropriately
'====================================================================================
Public Sub Animate()
    If MyFrameCount = 0 Then Exit Sub
    Me.CurrentFrame = (Me.CurrentFrame + 1) Mod MyFrameCount
End Sub

'====================================================================================
'Draw: Alphablend the image to specified surface
'====================================================================================
Public Function Draw(ByVal hDC As Long, ByVal DestLeft As Long, ByVal DestTop As Long, Optional ByVal Opaque As Long = 255) As Long
    'Set transparency level
    If Opaque = 255 Then Opaque = &H1FF0000 Else Opaque = &H1000000 Or (Opaque * &H10000)
    'Draw the whole image (if unanimated), or the current frame (if animated)
    Draw = AlphaBlending(hDC, DestLeft, DestTop, MyFrameWidth, MyBitmapInfo.bmiHeader.biHeight, _
                         MyhDC, (MyFrameWidth * Me.CurrentFrame), 0, MyFrameWidth, MyBitmapInfo.bmiHeader.biHeight, Opaque)
End Function

'====================================================================================
'DrawEx: Draw the image, but provide cropping options
'====================================================================================
Public Function DrawEx(ByVal hDC As Long, ByVal DestLeft As Long, ByVal DestTop As Long, ByVal DestWidth As Long, ByVal DestHeight As Long, ByVal SrcLeft As Long, ByVal SrcTop As Long, Optional ByVal Opaque As Long = 255) As Long
    'Set transparency level
    If Opaque = 255 Then Opaque = &H1FF0000 Else Opaque = &H1000000 Or (Opaque * &H10000)
    'You can't use DrawEx on animated images
    DrawEx = AlphaBlending(hDC, DestLeft, DestTop, DestWidth, DestHeight, _
                           MyhDC, SrcLeft, SrcTop, DestWidth, DestHeight, Opaque)
End Function

'====================================================================================
'Create: Initialise a new DIBImage (error check too)
'====================================================================================
Public Function Create(ByVal lWidth As Long, ByVal lHeight As Long) As Boolean
    'Delete any existing image
    p_ClearUp
    
    MyhDC = CreateCompatibleDC(0)
    If (MyhDC <> 0) Then
        'Attempt to create an image with dimensions given
        If (p_CreateDIB(MyhDC, lWidth, lHeight, MyDIB)) Then
            'Creation succeeded
            MyBMPOld = SelectObject(MyhDC, MyDIB)
            
            MyFrameCount = 0: MyFrameWidth = MyBitmapInfo.bmiHeader.biWidth
            Me.CurrentFrame = 0
            
            Create = True
        Else
            'Creation failed
            DeleteObject MyhDC: MyhDC = 0
        End If
    End If
End Function

'====================================================================================
'PRIVATE CreateDIB: Initialise a blank DIB surface (subpart of Create above)
'====================================================================================
Private Function p_CreateDIB(ByVal lhDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByRef hDib As Long) As Boolean
    'Set BITMAPINFO parameters, size, colour depth etc
    With MyBitmapInfo.bmiHeader
        .biSize = Len(MyBitmapInfo.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    
    'Create the data array
    hDib = CreateDIBSection(lhDC, MyBitmapInfo, DIB_RGB_COLORS, MyPointer, 0, 0)
    p_CreateDIB = (hDib <> 0)
End Function

'====================================================================================
'LoadTGA32: Loads a TGA file with alpha channel into a 32-bit HDc
'====================================================================================
Public Function LoadTGA32(File As String, Optional ByVal IsAnimated As Boolean = False) As Long
    Dim K As Long, r As Long, Fail As Boolean
    Dim TGAWidth As Long, TGAHeight As Long
    Dim TGAHdr As TGAHeader
    Dim Bits() As RGBQUAD
    Dim SizeCount As Long
    
    Open File For Binary Access Read As 1
        'Get TGA header from file
        Get #1, , TGAHdr
        'We only want to load a 32 bit unindexed alpha tga file
        If Not (TGAHdr.IDLength = 0) Then Fail = True        'Fail if file doesn't exist
        If Not (TGAHdr.ImageType = 2) Then Fail = True       'if file is indexed
        If Not (TGAHdr.PixelDepth = 32) Then Fail = True     'if not 32 bit pixels
        If Not (TGAHdr.ColorMapType = 0) Then Fail = True    'if has pallete
        If Not (TGAHdr.ImageDescriptor = 8) Then Fail = True 'if origin is not upper left
        'Get Unindexed Bits, 32 bytes each
        If Fail = False Then
            TGAWidth = TGAHdr.Width
            TGAHeight = TGAHdr.Height
            SizeCount = (TGAWidth * TGAHeight) - 1
            ReDim Bits(0 To SizeCount) 'Resize bit array, simple W*H
            For K = 0 To (TGAWidth * TGAHeight) - 1
                Get #1, , Bits(K)
            Next K
        End If
    Close
    'Continue with operation
    If Fail = False Then
        'Alpha rgb pixels must have the same intensity as their alpha value.
        'If the TGA rgb pixels are not already set to the right intensity
        'we set them here. To acheive various effects try not using this.
        For K = 0 To TGAWidth * TGAHeight - 1: p_multpixel Bits(K): Next K
        
        'Create a new, blank 32-bit DIB image
        Create TGAHdr.Width, TGAHdr.Height
        
        'This is where we set the DIB bits using an array of RGBQUAD structures
        'This can be used to set any alpha bits needed
        r = SetDIBits(MyhDC, MyDIB, 0, MyBitmapInfo.bmiHeader.biHeight, Bits(0), MyBitmapInfo, DIB_RGB_COLORS)
        'Select the bitmap into the DC
        r = SelectObject(MyhDC, MyDIB)
        'delete the original bitmap
        r = DeleteObject(r)
        'Return the DC handle
        LoadTGA32 = MyhDC
    End If
    
    'If the image loaded is to be an animation,
    If IsAnimated = True Then
        MyFrameCount = (Me.Width \ Me.Height)     'Number of frames
        MyFrameWidth = (Me.Width \ MyFrameCount)   'Width of each frame
    Else
        MyFrameCount = 0: MyFrameWidth = Me.Width  'No animation
    End If
    Me.CurrentFrame = 0
End Function

'====================================================================================
'PRIVATE multpixel: turns a 24-bit number into a 32-bit one
'====================================================================================
Private Sub p_multpixel(ByRef p As RGBQUAD)
    Dim Rbuf, Gbuf, Bbuf, Abuf As Single
    
    'Sets the intensity of the RGB value to the A value
    Rbuf = p.rgbRed: Gbuf = p.rgbGreen: Bbuf = p.rgbBlue: Abuf = p.rgbReserved
    p.rgbRed = CByte(Rbuf * Abuf / 255)
    p.rgbGreen = CByte(Gbuf * Abuf / 255)
    p.rgbBlue = CByte(Bbuf * Abuf / 255)
End Sub

'====================================================================================
'PRIVATE ClearUp: Erase the DIB section and free the memory
'====================================================================================
Private Sub p_ClearUp()
    If (MyhDC <> 0) Then
        If (MyDIB <> 0) Then
            SelectObject MyhDC, MyBMPOld
            DeleteObject MyDIB
        End If
        DeleteObject MyhDC
    End If
    MyhDC = 0: MyDIB = 0: MyBMPOld = 0: MyPointer = 0
End Sub

'====================================================================================
'CLASS Terminate - When the garbage collector comes, free up memory
'====================================================================================
Private Sub Class_Terminate()
    p_ClearUp
End Sub

'=== END ============================================================================
'This work is licenced under the Creative Commons Attribution 2.5 License
